home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _59bc847b67258baa1c9f8174348cd82f < prev    next >
Encoding:
Text File  |  2002-05-30  |  8.3 KB  |  374 lines
  1. # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Frame;
  5. require Tk::Widget;
  6. require Tk::Derived;
  7. use AutoLoader;
  8. use strict qw(vars);
  9. use Carp;
  10.  
  11. use base qw(Tk::Derived Tk::Widget);
  12.  
  13. Construct Tk::Widget 'Frame';
  14.  
  15.  
  16. use vars qw($VERSION);
  17. $VERSION = '3.031'; # $Id: //depot/Tk8/Tk/Frame.pm#31 $
  18.  
  19. sub Tk_cmd { \&Tk::frame }
  20.  
  21. sub CreateOptions
  22. {
  23.  return (shift->SUPER::CreateOptions,'-colormap','-visual','-container')
  24. }
  25.  
  26. sub Default
  27. {
  28.  my ($cw,$name,$widget)  = @_;
  29.  confess 'No name' unless (defined $name);
  30.  croak 'No widget' unless (defined $widget);
  31.  $cw->Delegates(DEFAULT => $widget);
  32.  $cw->ConfigSpecs(DEFAULT => [$widget]);
  33.  $widget->pack('-expand' => 1, -fill => 'both') unless ($widget->manager);  # Suspect
  34.  $cw->Advertise($name,$widget);
  35. }
  36.  
  37. sub ConfigDelegate
  38. {
  39.  my ($cw,$name,@skip) = @_;
  40.  my $sw = $cw->Subwidget($name);
  41.  my $sc;
  42.  my %skip = ();
  43.  foreach $sc (@skip)
  44.   {
  45.    $skip{$sc} = 1;
  46.   }
  47.  foreach $sc ($sw->configure)
  48.   {
  49.    my (@info) = @$sc;
  50.    next if (@info == 2);
  51.    my $option = $info[0];
  52.    unless ($skip{$option})
  53.     {
  54.      $option =~ s/^-(.*)/-$name\u$1/;
  55.      $info[0] = Tk::Configure->new($sw,$info[0]);
  56.      pop(@info);
  57.      $cw->ConfigSpecs($option => \@info);
  58.     }
  59.   }
  60. }
  61.  
  62. sub bind
  63. {my ($cw,@args) = @_;
  64.  $cw->Delegate('bind',@args);
  65. }
  66.  
  67. sub menu
  68. {my ($cw,@args) = @_;
  69.  $cw->Delegate('menu',@args);
  70. }
  71.  
  72. sub focus
  73. {my ($cw,@args) = @_;
  74.  $cw->Delegate('focus',@args);
  75. }
  76.  
  77. #sub bindtags
  78. #{my ($cw,@args) = @_;
  79. # $cw->Delegate('bindtags',@args);
  80. #}
  81.  
  82. sub selection
  83. {my ($cw,@args) = @_;
  84.  $cw->Delegate('selection',@args);
  85. }
  86.  
  87. sub Populate
  88. {
  89.  my ($cw,$args) = @_;
  90.  $cw->ConfigSpecs('-labelPack'     => [ 'METHOD', undef, undef, undef]);
  91.  $cw->ConfigSpecs('-labelVariable' => [ 'METHOD', undef, undef, undef]);
  92.  $cw->ConfigSpecs('-label'         => [ 'METHOD', undef, undef, undef]);
  93.  $cw->labelPack([]) if grep /^-label\w+/, keys %$args;
  94. }
  95.  
  96. sub Menubar
  97. {
  98.  my $frame = shift;
  99.  my $menu = $frame->cget('-menu');
  100.  if (defined $menu)
  101.   {
  102.    $menu->configure(@_) if @_;
  103.   }
  104.  else
  105.   {
  106.    $menu = $frame->Menu(-type => 'menubar',@_);
  107.    $frame->configure('-menu' => $menu);
  108.   }
  109.  $frame->Advertise('menubar' => $menu);
  110.  return $menu;
  111. }
  112.  
  113. 1;
  114.  
  115. __END__
  116.  
  117. sub labelPack
  118. {
  119.  my ($cw,$val) = @_;
  120.  my $w = $cw->Subwidget('label');
  121.  my @result = ();
  122.  if (@_ > 1)
  123.   {
  124.    if (defined($w) && !defined($val))
  125.     {
  126.      $w->packForget;
  127.     }
  128.    elsif (defined($val) && !defined ($w))
  129.     {
  130.      require Tk::Label;
  131.      $w = Tk::Label->new($cw,-textvariable => $cw->labelVariable);
  132.      $cw->Advertise('label' => $w);
  133.      $cw->ConfigDelegate('label',qw(-text -textvariable));
  134.     }
  135.    if (defined($val) && defined($w))
  136.     {
  137.      my %pack = @$val;
  138.      unless (exists $pack{-side})
  139.       {
  140.        $pack{-side} = 'top' unless (exists $pack{-side});
  141.       }
  142.      unless (exists $pack{-fill})
  143.       {
  144.        $pack{-fill} = 'x' if ($pack{-side} =~ /(top|bottom)/);
  145.        $pack{-fill} = 'y' if ($pack{-side} =~ /(left|right)/);
  146.       }
  147.      unless (exists($pack{'-before'}) || exists($pack{'-after'}))
  148.       {
  149.        my $before = ($cw->packSlaves)[0];
  150.        $pack{'-before'} = $before if (defined $before);
  151.       }
  152.      $w->pack(%pack);
  153.     }
  154.   }
  155.  @result = $w->packInfo if (defined $w);
  156.  return (wantarray) ? @result : \@result;
  157. }
  158.  
  159. sub labelVariable
  160. {
  161.  my ($cw,$val) = @_;
  162.  my $var = \$cw->{Configure}{'-labelVariable'};
  163.  if (@_ > 1 && defined $val)
  164.   {
  165.    $$var = $val;
  166.    $$val = '' unless (defined $$val);
  167.    my $w = $cw->Subwidget('label');
  168.    unless (defined $w)
  169.     {
  170.      $cw->labelPack([]);
  171.      $w = $cw->Subwidget('label');
  172.     }
  173.    $w->configure(-textvariable => $val);
  174.   }
  175.  return $$var;
  176. }
  177.  
  178. sub label
  179. {
  180.  my ($cw,$val) = @_;
  181.  my $var = $cw->cget('-labelVariable');
  182.  if (@_ > 1 && defined $val)
  183.   {
  184.    if (!defined $var)
  185.     {
  186.      $var = \$cw->{Configure}{'-label'};
  187.      $cw->labelVariable($var);
  188.     }
  189.    $$var = $val;
  190.   }
  191.  return (defined $var) ? $$var : undef;;
  192. }
  193.  
  194. sub queuePack
  195. {
  196.  my ($cw) = @_;
  197.  unless ($cw->{'pack_pending'})
  198.   {
  199.    $cw->{'pack_pending'} = 1;
  200.    $cw->afterIdle([$cw,'packscrollbars']);
  201.   }
  202. }
  203.  
  204. sub sbset
  205. {
  206.  my ($cw,$sb,$ref,@args) = @_;
  207.  $sb->set(@args);
  208.  $cw->queuePack if (@args == 2 && $sb->Needed != $$ref);
  209. }
  210.  
  211. sub freeze_on_map
  212. {
  213.  my ($w) = @_;
  214.  unless ($w->Tk::bind('Freeze','<Map>'))
  215.   {
  216.    $w->Tk::bind('Freeze','<Map>',['packPropagate' => 0])
  217.   }
  218.  $w->AddBindTag('Freeze');
  219. }
  220.  
  221. sub AddScrollbars
  222. {
  223.  require Tk::Scrollbar;
  224.  my ($cw,$w) = @_;
  225.  my $def = '';
  226.  my ($x,$y) = ('','');
  227.  my $s = 0;
  228.  my $c;
  229.  $cw->freeze_on_map;
  230.  foreach $c ($w->configure)
  231.   {
  232.    my $opt = $c->[0];
  233.    if ($opt eq '-yscrollcommand')
  234.     {
  235.      my $slice  = Tk::Frame->new($cw,Name => 'ysbslice');
  236.      my $ysb    = Tk::Scrollbar->new($slice,-orient => 'vertical', -command => [ 'yview', $w ]);
  237.      my $size   = $ysb->cget('-width');
  238.      my $corner = Tk::Frame->new($slice,Name=>'corner','-relief' => 'raised',
  239.                   '-width' => $size, '-height' => $size);
  240.      $ysb->pack(-side => 'left', -fill => 'y');
  241.      $cw->Advertise('yscrollbar' => $ysb);
  242.      $cw->Advertise('corner' => $corner);
  243.      $cw->Advertise('ysbslice' => $slice);
  244.      $corner->{'before'} = $ysb->PathName;
  245.      $slice->{'before'} = $w->PathName;
  246.      $y = 'w';
  247.      $s = 1;
  248.     }
  249.    elsif ($opt eq '-xscrollcommand')
  250.     {
  251.      my $xsb = Tk::Scrollbar->new($cw,-orient => 'horizontal', -command => [ 'xview', $w ]);
  252.      $cw->Advertise('xscrollbar' => $xsb);
  253.      $xsb->{'before'} = $w->PathName;
  254.      $x = 's';
  255.      $s = 1;
  256.     }
  257.   }
  258.  if ($s)
  259.   {
  260.    $cw->Advertise('scrolled' => $w);
  261.    $cw->ConfigSpecs('-scrollbars' => ['METHOD','scrollbars','Scrollbars',$x.$y]);
  262.   }
  263. }
  264.  
  265. sub packscrollbars
  266. {
  267.  my ($cw) = @_;
  268.  my $opt    = $cw->cget('-scrollbars');
  269.  my $slice  = $cw->Subwidget('ysbslice');
  270.  my $xsb    = $cw->Subwidget('xscrollbar');
  271.  my $corner = $cw->Subwidget('corner');
  272.  my $w      = $cw->Subwidget('scrolled');
  273.  my $xside  = (($opt =~ /n/) ? 'top' : 'bottom');
  274.  my $havex  = 0;
  275.  my $havey  = 0;
  276.  $opt =~ s/r//;
  277.  $cw->{'pack_pending'} = 0;
  278.  if (defined $slice)
  279.   {
  280.    my $reqy;
  281.    my $ysb    = $cw->Subwidget('yscrollbar');
  282.    if ($opt =~ /(o)?[we]/ && (($reqy = !defined($1)) || $ysb->Needed))
  283.     {
  284.      my $yside = (($opt =~ /w/) ? 'left' : 'right');
  285.      $slice->pack(-side => $yside, -fill => 'y',-before => $slice->{'before'});
  286.      $havey = 1;
  287.      if ($reqy)
  288.       {
  289.        $w->configure(-yscrollcommand => ['set', $ysb]);
  290.       }
  291.      else
  292.       {
  293.        $w->configure(-yscrollcommand => ['sbset', $cw, $ysb, \$cw->{'packysb'}]);
  294.       }
  295.     }
  296.    else
  297.     {
  298.      $w->configure(-yscrollcommand => undef) unless $opt =~ s/[we]//;
  299.      $slice->packForget;
  300.     }
  301.    $cw->{'packysb'} = $havey;
  302.   }
  303.  if (defined $xsb)
  304.   {
  305.    my $reqx;
  306.    if ($opt =~ /(o)?[ns]/ && (($reqx = !defined($1)) || $xsb->Needed))
  307.     {
  308.      $xsb->pack(-side => $xside, -fill => 'x',-before => $xsb->{'before'});
  309.      $havex = 1;
  310.      if ($reqx)
  311.       {
  312.        $w->configure(-xscrollcommand => ['set', $xsb]);
  313.       }
  314.      else
  315.       {
  316.        $w->configure(-xscrollcommand => ['sbset', $cw, $xsb, \$cw->{'packxsb'}]);
  317.       }
  318.     }
  319.    else
  320.     {
  321.      $w->configure(-xscrollcommand => undef) unless $opt =~ s/[ns]//;
  322.      $xsb->packForget;
  323.     }
  324.    $cw->{'packxsb'} = $havex;
  325.   }
  326.  if (defined $corner)
  327.   {
  328.    if ($havex && $havey && defined $corner->{'before'})
  329.     {
  330.      my $anchor = $opt;
  331.      $anchor =~ s/o//g;
  332.      $corner->configure(-height => $xsb->ReqHeight);
  333.      $corner->pack(-before => $corner->{'before'}, -side => $xside,
  334.                    -anchor => $anchor, -fill => 'x');
  335.     }
  336.    else
  337.     {
  338.      $corner->packForget;
  339.     }
  340.   }
  341. }
  342.  
  343. sub scrollbars
  344. {
  345.  my ($cw,$opt) = @_;
  346.  my $var = \$cw->{'-scrollbars'};
  347.  if (@_ > 1)
  348.   {
  349.    my $old = $$var;
  350.    if (!defined $old || $old ne $opt)
  351.     {
  352.      $$var = $opt;
  353.      $cw->queuePack;
  354.     }
  355.   }
  356.  return $$var;
  357. }
  358.  
  359. sub FindMenu
  360. {
  361.  my ($w,$char) = @_;
  362.  my $child;
  363.  my $match;
  364.  foreach $child ($w->children)
  365.   {
  366.    next unless (ref $child);
  367.    $match = $child->FindMenu($char);
  368.    return $match if (defined $match);
  369.   }
  370.  return undef;
  371. }
  372.  
  373.  
  374.